COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Travelling Salesman
C00005 00003	 (setq l
C00007 00004	 Controller
C00010 00005	 The main Program
C00012 ENDMK
C⊗;
;;; Travelling Salesman

(declare (special *start* *all-nodes*))

(fasload struct fas dsk (mac lsp))
(fasload sharpm fas dsk (mac lsp))
(fasload setf fas dsk (mac lsp))

(defstruct node
	   (name ())
	   (arcs ()))

(defstruct arc
	   (node ())
	   (cost 0)) 

;;; (...(a b 10)...)

(defun make-graph (links start finish)
       (let ((nodes ())
	     (full-links ()))
	    (mapc #'(lambda (x)
			    (cond ((not (memq (car x)
					      nodes))
				   (push (car x) nodes)))
			    (cond ((not (memq (cadr x)
					      nodes))
				   (push (cadr x) nodes)))
			    (push x full-links)
			    (let ((temp `(,(cadr x) ,(car x) ,(caddr x))))
				 (cond ((not (member temp full-links))
					(push temp full-links)))))
		  links)
	    (setq nodes
		  (mapcar #'(lambda (node)
				    `(,node . ,(make-node name node)))
			  nodes))
	    (mapcar 
	     #'(lambda (entry)
		       (let ((node (cdr entry)))
			    (mapcar 
			     #'(lambda (link)
           			       (setf (arcs node)
					     (cons (make-arc 
						    node 
						    (cdr (assq (cadr link)
							       nodes))
						    cost (caddr link))
						   (arcs node))))
			     (mapcan #'(lambda (q)
					       (cond ((eq (car entry)
							  (car q))
						      (ncons q))))
				     full-links))))
	     nodes)
	    (list (cdr (assq start nodes))
		  (cdr (assq finish nodes))
		  (mapcar #'cdr nodes))))

(defun node-name (x) (name x))
(defun arc-cost (x) (cost x))
(defun arc-node (x) (node x))
(defun node-arcs (x) (arcs x))

(defun init (l start)
       (let ((q (make-graph l start start)))
	    (setq *start* (car q)
		  *all-nodes* (caddr q))))

 (setq l
       '((a b 10)(b c 10)(b d 20)(c d 10)(d e 10)(e a 5)))

(setq l
      '((a b 10)(b c 10)(c a 20)))

(setq prinlevel 4 prinlength 10)
(init l 'a)
(*rset (nouuo t))
(find-path)
T 
Number of Processors:	16
Processes Created:	0
Processes Scheduled:	1
Read Conflicts:		0
Write Conflicts:	0
Wait Cycles:		0
Active Cycles:		16
Multiprocessor Steps:	17
=> 
(EXPLORING A PATH = (A) COST = 0) 
;NIL INVALID OR WRONG LENGTH HUNK
;BKPT WRNG-TYPE-ARG
BAKTRACE
+INTERNAL-WTA-BREAK← CXR← ARC-NODE← ?←? M-LISP-CALL← ?←? ?←? ?←? ?←? ?←? 
?←? STARTUP← 
NIL 
((ARCS) (CONTROLLER QCLOSURE (TYPE MESSAGE) (NORMAL . NIL . (# . NIL . 
NIL . TAIL-RECURSIVE . # . NIL . M-CLOSURE-WAITER . NIL . NIL . # . # . 
NIL . READY . # .) . NIL .)) (NODE . ((# #) . A .)) (PATH-COST . 0) (PATH)) 
(setq node (cdr (assq 'node *environment*)))
(((10 . (# . B .) .) (5 . (# . E .) .)) . A .) 
(node-arcs node)
((10 . ((# # #) . B .) .) (5 . ((# #) . E .) .)) 
;;; Controller

(m-defun find-path ()
	 (setq *best-cost* 9999)
	 (setq *best-path* ())
	 (let 
	  ((controller 
	    (qlambda 
	     t (type message)
	     (cond 
	      ((eq type 'progress-report)
	       (let ((cost (car message))
		     (node (cadr message)))
		    (cond ((≤ *best-cost* cost)
			   (print `(killing process with cost = ,(car message)))
			   (funcall (qlambda t () (funcall (cadddr message)))))
			  (t
			   (setq *best-cost* cost)
			   (setq *best-path* (caddr message))
			   (print `(found path with
					  cost = ,*best-cost*))))))
	      (t (print `(bad message type = ,type)))))))
	  (qcatch 'the-end 
		  (explore
		   controller *start* 0 ()))
	  (setq result (the-path *best-path*))
	  (print-best-path)))

(defun print-best-path ()
       (terpri)(princ "Cost of best route ")(princ *best-cost*)
       (print (mapcar #'(lambda (q) (name q)) (cons *start* (reverse *best-path*)))))

(m-defun complete-pathp (nodes)
	 (do ((all-nodes *all-nodes* (cdr all-nodes)))
	     ((null all-nodes) t)
	     (cond ((not (memq (car all-nodes) nodes))
		    (return ())))))

(defun the-path (l)
       (mapcar #'(lambda (q) (name q)) (cons *start* (reverse l))))
;;; The main Program
;;; *best*-cost*, *start*, and *end* are globals

(m-defun explore (controller node path-cost path)
 (qcatch 'death
	 (progn
	  (print `(exploring ,(node-name node) path = ,(the-path path)
			     cost = ,path-cost))
	  (cond ((≤ *best-cost* path-cost)
		 (print `(suicide with cost = ,path-cost)))
		((and (eq node *start*)
		      (complete-pathp path))
		 (controller 'progress-report
			     `(,path-cost
			       ,node
			       ,path
			       ,(qlambda t ()
					 (throw 'death ())))))
		(t (do ((arcs (node-arcs node)
			      (cdr arcs)))
		       ((null arcs) t)
		       (funcall 
			(qlambda 
			 t ()
			 (explore controller (arc-node (car arcs))
				  (+ path-cost (arc-cost (car arcs)))
				  (cons (arc-node (car arcs)) path))))))))))